﻿Imports System
Imports System.Collections.Generic
Imports System.Text
Imports Microsoft.Exchange.Data.Transport
Imports Microsoft.Exchange.Data.Transport.Routing
Imports ProcessAttachmentAndSecureText.EWS


Namespace CustomAgents

    NotInheritable Class CustomAgentFactory
        Inherits RoutingAgentFactory

        Public Overrides Function CreateAgent(ByVal server As SmtpServer) As RoutingAgent
            Return New ProcessAttachmentAndSecureText
        End Function
    End Class

    Public Class ProcessAttachmentAndSecureText
        Inherits RoutingAgent

        Dim strParmLocation As String = Reflection.Assembly.GetExecutingAssembly().Location & ".config"

        Dim strBaseFolder As String
        Dim strExchangeUserid As String
        Dim strExchangePassword As String
        Dim strExchangeDomainName As String
        Dim strExchangeUrl As String
        Dim strMessageSensitivityTrigger As String
        Dim strMessageSizeTrigger As String
        Dim strProcessAttachmentAndSecureTextUrl As String

        Private Sub ProcessAttachmentOnSubmittedMessage(source As SubmittedMessageEventSource, e As QueuedMessageEventArgs) Handles Me.OnSubmittedMessage
            Try
                If e.MailItem.InboundDeliveryMethod <> DeliveryMethod.Mailbox Then Exit Sub 'PREVENTS OUTSIDE USERS FROM SUBMITTING TO THIS TRANSPORT RULE
                Dim strPasswordToDisplay As String = ""
                Dim strPasswordPermanent As String = ""
                Dim bolWorkToBeDone As Boolean = False
                Dim bolStripAttachment As Boolean = False
                Dim bolStripBody As Boolean = False
                Dim strGUID As String = System.Guid.NewGuid.ToString
                strPasswordToDisplay = CreatePassword(6)
                strPasswordPermanent = strPasswordToDisplay
                Dim strMessageSize = e.MailItem.MimeStreamLength 'THERE IS A CLOSE TIE TO ATTACHMENT SIZE AND MIMESTREAMLENGTH.  MIMESTREAMLENGTH IS IN KB
                strMessageSizeTrigger = ReadParm(strParmLocation, "MessageSizeTrigger")
                Dim intMessageSizeTrigger As Integer
                If strMessageSizeTrigger = "" Or IsNumeric(strMessageSizeTrigger) = False Then
                    intMessageSizeTrigger = 0
                Else
                    intMessageSizeTrigger = strMessageSizeTrigger
                End If
                If intMessageSizeTrigger > 0 AndAlso strMessageSize > intMessageSizeTrigger Then e.MailItem.Message.Subject += "PROCESSATTACHMENT"
                Dim strMessageSensitivity = e.MailItem.Message.Sensitivity
                strMessageSensitivityTrigger = ReadParm(strParmLocation, "MessageSensitivityTrigger")
                Dim bolMessageSensitivityTrigger As Boolean
                If UCase(strMessageSensitivityTrigger) = "ENABLED" Then
                    bolMessageSensitivityTrigger = True
                Else
                    bolMessageSensitivityTrigger = False
                End If
                If bolMessageSensitivityTrigger = True AndAlso e.MailItem.Message.Sensitivity = Email.Sensitivity.CompanyConfidential Then e.MailItem.Message.Subject += "SECURE"

                If e.MailItem.Message.Subject.Contains("PROCESSATTACHMENT") = True Or e.MailItem.Message.Subject.Contains("SECURE") = True Then
                    LoadAllParms()
                    If CheckAllParms() = False Then
                        e.MailItem.Message.Subject += " Missing Parm in " & strParmLocation
                        Exit Sub
                    End If
                End If

                If e.MailItem.Message.Subject.Contains("PROCESSATTACHMENT") = True Then
                    bolWorkToBeDone = True
                    bolStripAttachment = True
                    e.MailItem.Message.Subject = e.MailItem.Message.Subject.Replace("PROCESSATTACHMENT", "")
                    Dim intNumberOfAttachements As Integer = e.MailItem.Message.Attachments.Count
                    If intNumberOfAttachements > 0 Then
                        My.Computer.FileSystem.CreateDirectory(strBaseFolder & strGUID)
                        Dim intLoop As Integer = 0
                        While intLoop < intNumberOfAttachements
                            intLoop += 1
                            Dim objAttachment As Email.Attachment = e.MailItem.Message.Attachments(intNumberOfAttachements - intLoop) 'LOOP IN REVERSE ORDER TO PREVENT PROBLEMS WHEN THE ATTACHMENT IS DELETED
                            SaveAttachmentOrBodyToFile(objAttachment.GetContentReadStream, objAttachment.GetContentReadStream.Length, strBaseFolder & strGUID & "\" & objAttachment.FileName)
                            e.MailItem.Message.Attachments.Remove(objAttachment)
                        End While
                    End If
                End If
                If e.MailItem.Message.Subject.Contains("SECURE") = True Then
                    bolWorkToBeDone = True
                    bolStripBody = True
                    e.MailItem.Message.Subject = e.MailItem.Message.Subject.Replace("SECURE", "")
                    Dim objBody As Email.Body = e.MailItem.Message.Body
                    My.Computer.FileSystem.CreateDirectory(strBaseFolder & strGUID & "\meta")
                    SaveAttachmentOrBodyToFile(objBody.GetContentReadStream, objBody.GetContentReadStream.Length, strBaseFolder & strGUID & "\meta\content.txt")
                    strPasswordToDisplay = "<i>reach out to the sender to discover the password because it has been hidden</i>"
                End If

                If bolWorkToBeDone = False Then Exit Sub 'EXIT THE ROUTINE IF NO WORK NEEDS TO BE DONE

                'CREATE THE PARM FILES
                Dim strParmContents As String = ""
                strParmContents += "SENDER=" & e.MailItem.Message.From.SmtpAddress & vbCrLf
                Dim strRecipients As String = ""
                For Each strRecipient As EnvelopeRecipient In e.MailItem.Recipients
                    strRecipients += strRecipient.Address.ToString & ","
                Next
                strParmContents += "RECEIVERS=" & strRecipients & vbCrLf
                strParmContents += "PASSWORD=" & strPasswordPermanent & vbCrLf
                If IO.Directory.Exists(strBaseFolder & strGUID & "\meta") = False Then My.Computer.FileSystem.CreateDirectory(strBaseFolder & strGUID & "\meta")
                My.Computer.FileSystem.WriteAllText(strBaseFolder & strGUID & "\meta\parm.dat", strParmContents, False)

                'ALTER ORIGINAL RECIPIENTS SO THE MESSAGE GETS SENT TO THE SENDER
                If e.MailItem.Recipients.CanAdd = True Then e.MailItem.Recipients.Add(e.MailItem.Message.From.SmtpAddress) 'THIS LINE WILL NOT RUN OnRoutedMessage IT WILL ONLY WORK OnSubmittedMessage OR EARLIER

                'CLEAR ORIGINAL MESSAGE BODY IF SECURETEXT IS SPECIFIED
                If bolStripBody = True Then
                    Dim objBodyStreamReaderClear As New System.IO.MemoryStream
                    Dim objBodyStreamWriterClear = e.MailItem.Message.Body.GetContentWriteStream()
                    Dim objEncodingClear = Microsoft.Exchange.Data.Globalization.Charset.GetEncoding(e.MailItem.Message.Body.CharsetName)
                    Dim objTextToTextConversionClear
                    If e.MailItem.Message.Body.BodyFormat = Email.BodyFormat.Html Then
                        objTextToTextConversionClear = New Microsoft.Exchange.Data.TextConverters.HtmlToHtml
                    ElseIf e.MailItem.Message.Body.BodyFormat = Email.BodyFormat.Rtf Then
                        objTextToTextConversionClear = New Microsoft.Exchange.Data.TextConverters.RtfToRtf
                    Else
                        objTextToTextConversionClear = New Microsoft.Exchange.Data.TextConverters.TextToText
                    End If
                    objTextToTextConversionClear.InputEncoding = objEncodingClear
                    objTextToTextConversionClear.Convert(objBodyStreamReaderClear, objBodyStreamWriterClear)
                    objBodyStreamWriterClear.Close()
                    objBodyStreamReaderClear.Close()
                End If

                'ALTER ORIGINAL MESSAGE BODY
                Dim objBodyStreamReader = e.MailItem.Message.Body.GetContentReadStream()
                Dim objBodyStreamWriter = e.MailItem.Message.Body.GetContentWriteStream()
                Dim objEncoding = Microsoft.Exchange.Data.Globalization.Charset.GetEncoding(e.MailItem.Message.Body.CharsetName)
                Dim objTextToTextConversion
                Dim strMessageText As String = ""
                If bolStripBody = True And bolStripAttachment = True Then strMessageText = "View Attachment(s) and Secure Text"
                If bolStripBody = True And bolStripAttachment = False Then strMessageText = "View Secure Text"
                If bolStripBody = False And bolStripAttachment = True Then strMessageText = "View Attachment(s)"
                If e.MailItem.Message.Body.BodyFormat = Email.BodyFormat.Html Then
                    objTextToTextConversion = New Microsoft.Exchange.Data.TextConverters.HtmlToHtml
                    objTextToTextConversion.Header = "<a href=""" & strProcessAttachmentAndSecureTextUrl & strGUID & """>" & strMessageText & "</a> (Password: " & strPasswordToDisplay & ")<br>"
                    objTextToTextConversion.HeaderFooterFormat = Microsoft.Exchange.Data.TextConverters.HeaderFooterFormat.Html
                ElseIf e.MailItem.Message.Body.BodyFormat = Email.BodyFormat.Rtf Then
                    objTextToTextConversion = New Microsoft.Exchange.Data.TextConverters.RtfToRtf
                    objTextToTextConversion.Header = "Navigate to this url to " & strMessageText & ": " & strProcessAttachmentAndSecureTextUrl & strGUID & " (Password: " & strPasswordToDisplay.Replace("<i>", "").Replace("</i>", "") & ")" & vbCrLf
                    objTextToTextConversion.HeaderFooterFormat = Microsoft.Exchange.Data.TextConverters.HeaderFooterFormat.Text
                Else
                    objTextToTextConversion = New Microsoft.Exchange.Data.TextConverters.TextToText
                    objTextToTextConversion.Header = "Navigate to this url to " & strMessageText & ": " & strProcessAttachmentAndSecureTextUrl & strGUID & " (Password: " & strPasswordToDisplay.Replace("<i>", "").Replace("</i>", "") & ")" & vbCrLf
                    objTextToTextConversion.HeaderFooterFormat = Microsoft.Exchange.Data.TextConverters.HeaderFooterFormat.Text
                End If
                objTextToTextConversion.InputEncoding = objEncoding
                objTextToTextConversion.Convert(objBodyStreamReader, objBodyStreamWriter)
                objBodyStreamWriter.Close()
                objBodyStreamReader.Close()
                Dim esb As New EWS.ExchangeServiceBinding()
                esb.RequestServerVersionValue = New RequestServerVersion()
                esb.RequestServerVersionValue.Version = ExchangeVersionType.Exchange2010_SP1
                esb.Credentials = New Net.NetworkCredential(strExchangeUserid, strExchangePassword, strExchangeDomainName)
                esb.Url = strExchangeUrl
                Dim objExchangeImpersonation As New ExchangeImpersonationType()
                Dim objConnectingSid As New ConnectingSIDType()
                objConnectingSid.ItemElementName = ItemChoiceType.PrimarySmtpAddress
                objConnectingSid.Item = e.MailItem.Message.From.SmtpAddress
                objExchangeImpersonation.ConnectingSID = objConnectingSid
                esb.ExchangeImpersonation = objExchangeImpersonation
                If bolStripBody = True Then CreateEmail(esb, e.MailItem, "Password: " & strPasswordPermanent, "Password to unlock message: " & e.MailItem.Message.Subject, e.MailItem.Message.From.SmtpAddress, e.MailItem.Message.From.SmtpAddress)
                FindMessageAndDeleteViaWebService(esb, e.MailItem.Message.MessageId)
            Catch
                e.MailItem.Message.Subject += " " & Err.Description
            End Try
        End Sub

        Private Sub CreateEmail(esb As ExchangeServiceBinding, pobjMailItem As MailItem, pstrBody As String, pstrSubject As String, pstrSender As String, pstrRecipient As String)
            Dim objCreateItemRequest As New CreateItemType()
            objCreateItemRequest.MessageDisposition = MessageDispositionType.SendOnly
            objCreateItemRequest.MessageDispositionSpecified = True
            objCreateItemRequest.Items = New NonEmptyArrayOfAllItemsType()
            Dim objMessage As New MessageType()
            objMessage.Subject = pstrSubject
            objMessage.Body = New BodyType()
            objMessage.Body.BodyType1 = BodyTypeType.Text
            objMessage.Body.Value = pstrBody
            objMessage.ToRecipients = New EmailAddressType(0) {}
            objMessage.ToRecipients(0) = New EmailAddressType()
            objMessage.ToRecipients(0).EmailAddress = pstrRecipient
            objMessage.Importance = ImportanceChoicesType.High
            objMessage.ImportanceSpecified = True
            objCreateItemRequest.Items.Items = New ItemType(0) {}
            objCreateItemRequest.Items.Items(0) = objMessage
            Try
                Dim objCreateItemResponse As CreateItemResponseType = esb.CreateItem(objCreateItemRequest)
                If objCreateItemResponse.ResponseMessages.Items(0).ResponseClass = ResponseClassType.[Error] Then
                    Throw New Exception(objCreateItemResponse.ResponseMessages.Items(0).MessageText)
                Else
                End If
            Catch e As Exception
            End Try
        End Sub

        Private Function CreatePassword(pintDesiredLength As Integer) As String
            Dim strLetters As String = "12345ABCDEFGHIJKLMNOPQRSTUVWXYZ67890"
            Dim arrCharArray() As Char = strLetters.ToCharArray
            Dim objRandom As New Random
            Dim objStringBuilder As New System.Text.StringBuilder
            For intIndex As Integer = 1 To pintDesiredLength
                objStringBuilder.Append(arrCharArray(objRandom.Next(0, arrCharArray.Length)))
            Next
            Return objStringBuilder.ToString
        End Function

        Private Sub SaveAttachmentOrBodyToFile(pobjStream As IO.Stream, pobjStreamLength As Long, pstrFileName As String)
            Const BUFF_SIZE As Integer = 1024
            Dim objBytes As Byte() = New Byte(BUFF_SIZE - 1) {}
            Dim intBytesToRead As Integer = CInt(pobjStreamLength)
            Dim intBytesRead As Integer = 0
            Dim intJustRead As Integer = 1
            Dim objTargetFileStream As New IO.FileStream(pstrFileName, IO.FileMode.Create)
            Dim objBinaryWriter As New IO.BinaryWriter(objTargetFileStream)
            While intBytesToRead > 0 AndAlso intJustRead >= 0
                intJustRead = pobjStream.Read(objBytes, 0, Math.Min(intBytesToRead, BUFF_SIZE))
                intBytesRead += intJustRead
                intBytesToRead -= intJustRead
                objBinaryWriter.Write(objBytes, 0, intJustRead)
            End While
            objBinaryWriter.Close()
            objTargetFileStream.Close()
        End Sub

        Private Sub FindMessageAndDeleteViaWebService(esb As ExchangeServiceBinding, strInternalId As String)
            Dim objFindItemRequest As New FindItemType()
            objFindItemRequest.Traversal = ItemQueryTraversalType.Shallow
            Dim objItemProperties As New ItemResponseShapeType()
            objItemProperties.BaseShape = DefaultShapeNamesType.AllProperties
            objFindItemRequest.ItemShape = objItemProperties
            Dim objfolderIDArray As DistinguishedFolderIdType() = New DistinguishedFolderIdType(1) {}
            objfolderIDArray(0) = New DistinguishedFolderIdType()
            objfolderIDArray(0).Id = DistinguishedFolderIdNameType.sentitems
            objfolderIDArray(1) = New DistinguishedFolderIdType()
            objfolderIDArray(1).Id = DistinguishedFolderIdNameType.outbox
            objFindItemRequest.ParentFolderIds = objfolderIDArray
            Dim objHeaderField As New PathToUnindexedFieldType()
            objHeaderField.FieldURI = UnindexedFieldURIType.messageInternetMessageId
            Dim objContainsID As New ContainsExpressionType()
            objContainsID.Constant = New ConstantValueType()
            objContainsID.Constant.Value = strInternalId
            objContainsID.ContainmentComparison = ContainmentComparisonType.Exact
            objContainsID.ContainmentComparisonSpecified = True
            objContainsID.ContainmentMode = ContainmentModeType.ExactPhrase
            objContainsID.ContainmentModeSpecified = True
            objContainsID.Item = objHeaderField
            Dim objRestrict As New RestrictionType()
            objRestrict.Item = objContainsID
            objFindItemRequest.Restriction = objRestrict
            System.Threading.Thread.Sleep(60000) 'WAIT FOR 60 SECONDS TO ACCOUNT FOR CACHED MODE IN OUTLOOK WHICH DOESN'T MOVE THE MESSAGE TO SENT ITEMS ON THE SERVER FAST ENOUGH
            Try
                Dim objResponse As FindItemResponseType = esb.FindItem(objFindItemRequest)
                Dim objResponseMessage As FindItemResponseMessageType = TryCast(objResponse.ResponseMessages.Items(0), FindItemResponseMessageType)
                If objResponseMessage.ResponseCode <> ResponseCodeType.NoError Then
                    Throw New Exception(objResponseMessage.MessageText)
                Else
                    Dim arrItems As ArrayOfRealItemsType = TryCast(objResponseMessage.RootFolder.Item, ArrayOfRealItemsType)
                    For Each objItem As ItemType In arrItems.Items
                        DeleteItemViaWebService(esb, objItem) 'REMOVE THE ORIGINAL SENT ITEM MESSAGE TO FREE SPACE.  A REPLACEMENT WILL BE SENT
                    Next
                End If
            Catch e As Exception
            End Try
        End Sub

        Private Sub DeleteItemViaWebService(ByVal esb As ExchangeServiceBinding, objItemType As ItemType)
            Dim objDIT As DeleteItemType = New DeleteItemType()
            objDIT.ItemIds = New BaseItemIdType(1) {}
            objDIT.ItemIds(0) = objItemType.ItemId
            Try
                Dim objDIResponse As DeleteItemResponseType = esb.DeleteItem(objDIT)
                If objDIResponse.ResponseMessages.Items(0).ResponseClass = ResponseClassType.Error Then
                    Throw (New Exception(objDIResponse.ResponseMessages.Items(0).MessageText))
                End If
            Catch e As Exception
            End Try
        End Sub

        Private Sub LoadAllParms()
            Try
                strBaseFolder = ReadParm(strParmLocation, "BaseFolder")
                strExchangeUserid = ReadParm(strParmLocation, "ExchangeUserid")
                strExchangePassword = ReadParm(strParmLocation, "ExchangePassword")
                strExchangeDomainName = ReadParm(strParmLocation, "ExchangeDomainName")
                strExchangeUrl = ReadParm(strParmLocation, "ExchangeUrl")
                strProcessAttachmentAndSecureTextUrl = ReadParm(strParmLocation, "ProcessAttachmentAndSecureTextUrl")
            Catch e As Exception
            End Try
        End Sub

        Private Function CheckAllParms() As Boolean
            Try
                If strBaseFolder <> "" And strExchangeUserid <> "" And strExchangePassword <> "" And strExchangeDomainName <> "" And strExchangeUrl <> "" And strProcessAttachmentAndSecureTextUrl <> "" Then
                    Return True
                Else
                    Return False
                End If
            Catch e As Exception
                Return False
            End Try
        End Function

        Public Function ReadParm(ByVal pstrFileName As String, ByVal pstrParmName As String) As String
            Try
                Dim objReader As System.IO.StreamReader
                If System.IO.File.Exists(pstrFileName) = True Then
                    objReader = System.IO.File.OpenText(pstrFileName)
                    Dim strCurrentLine = objReader.ReadLine 'READS THE FIRST LINE OF THE PARM FILE
                    While Not IsNothing(strCurrentLine) 'LOOPS THROUGH THE FILE UNTIL COMPLETE OR UNTIL THE PARM NAME IS FOUND
                        If InStr(strCurrentLine, "=") > 0 Then
                            Dim strCurrentLineParmName As String = strCurrentLine
                            strCurrentLineParmName = Strings.Left(strCurrentLineParmName, (InStr(strCurrentLineParmName, "=") - 1))
                            If UCase(strCurrentLineParmName) = UCase(pstrParmName) Then 'PARSES LINE TO DISCOVER IF IT CONTAINS DESIRED PARM
                                objReader.Close()
                                Return Strings.Mid(strCurrentLine, (InStr(strCurrentLine, "=") + 1)) 'RETURNS THE PARM VALUE
                                Exit Function
                            End If
                        End If
                        strCurrentLine = objReader.ReadLine 'MOVES TO THE NEXT LINE
                    End While
                    objReader.Close()
                    Return ""
                    Exit Function
                Else
                    Return ""
                    Exit Function
                End If
            Catch
                Return ""
            End Try
        End Function
    End Class
End Namespace

